home *** CD-ROM | disk | FTP | other *** search
/ MacHack 1997 / MacHack 1997.toast / Hacks / Hacks ’94 / [√] Distribution Restricted! / Christian Ruse / Fourier Paper + Apps / nih-image154_source.sea / V1.54 Source / User.p < prev    next >
Text File  |  1993-12-06  |  11KB  |  421 lines
  1. unit User;
  2.  
  3. {This module is a good place to put user additions to Image. You will need }
  4. {to uncomment the call to InitUser in Image.p.}
  5.  
  6.  
  7. interface
  8.  
  9.     uses
  10.         QuickDraw, Palettes, PrintTraps, globals, Utilities, Graphics, Filters, Analysis;
  11.  
  12.  
  13.     procedure InitUser;
  14.     procedure DoUserCommand1;
  15.     procedure DoUserCommand2;
  16.     procedure DoUserMenuEvent (MenuItem: integer);
  17.     procedure OldUserMacroCode (CodeNumber: integer; Param1, Param2, Param3: extended);
  18.     procedure UserMacroCode (str: str255; Param1, Param2, Param3: extended);
  19.  
  20.  
  21. implementation
  22.  
  23. {User global variables go here.}
  24.     var
  25.         color, MinSpacing: integer;
  26.         SaveInfo: InfoPtr;
  27.         PeakRadius, Peakedness: extended;
  28.  
  29.  
  30.     procedure InitUser;
  31.     begin
  32.         UserMenuH := GetMenu(UserMenu);
  33.         InsertMenu(UserMenuH, 0);
  34.         DrawMenuBar;
  35. {Additional user initialization code goes here.}
  36.     end;
  37.  
  38.  
  39.     procedure DrawDot (row, column, RowOffset, ColumnOffset: integer; big: boolean);
  40.         var
  41.             h, v: integer;
  42.     begin
  43.         if big then begin
  44.                 for h := -1 to 1 do
  45.                     for v := -1 to 1 do
  46.                         PutPixel(column * 16 + ColumnOffset * 4 + h + 16, row * 16 + RowOffset * 4 + v + 16, color)
  47.             end
  48.         else
  49.             PutPixel(column * 16 + ColumnOffset * 4 + 16, row * 16 + RowOffset * 4 + 16, color);
  50.     end;
  51.  
  52.     procedure DrawNeighborhood (i, row, column: integer);
  53.  
  54.     begin
  55.         DrawDot(row, column, 0, 0, BitAnd(i, 1) = 1);
  56.         DrawDot(row, column, 0, 1, BitAnd(i, 2) = 2);
  57.         DrawDot(row, column, 0, 2, BitAnd(i, 4) = 4);
  58.         DrawDot(row, column, 1, 2, BitAnd(i, 8) = 8);
  59.         DrawDot(row, column, 2, 2, BitAnd(i, 16) = 16);
  60.         DrawDot(row, column, 2, 1, BitAnd(i, 32) = 32);
  61.         DrawDot(row, column, 2, 0, BitAnd(i, 64) = 64);
  62.         DrawDot(row, column, 1, 0, BitAnd(i, 128) = 128);
  63.         DrawDot(row, column, 1, 1, true);
  64.     end;
  65.  
  66.  
  67.     procedure SetColor (i: integer);
  68. {Color neighborhoods to show which ones would be removed on the first pass(150), second pass(100),}
  69. {or either pass(200) when using the Zhang and Suen thinning algorithm(CACM, Mar. 1984,236-239).}
  70.         var
  71.             p2, p3, p4, p5, p6, p7, p8, p9, A, B: integer;
  72.     begin
  73.         p2 := bsr(band(i, 2), 1);
  74.         p3 := bsr(band(i, 4), 2);
  75.         p4 := bsr(band(i, 8), 3);
  76.         p5 := bsr(band(i, 16), 4);
  77.         p6 := bsr(band(i, 32), 5);
  78.         p7 := bsr(band(i, 64), 6);
  79.         p8 := bsr(band(i, 128), 7);
  80.         p9 := band(i, 1);
  81.         A := 0;
  82.         if (p2 = 0) and (p3 = 1) then
  83.             A := A + 1;
  84.         if (p3 = 0) and (p4 = 1) then
  85.             A := A + 1;
  86.         if (p4 = 0) and (p5 = 1) then
  87.             A := A + 1;
  88.         if (p5 = 0) and (p6 = 1) then
  89.             A := A + 1;
  90.         if (p6 = 0) and (p7 = 1) then
  91.             A := A + 1;
  92.         if (p7 = 0) and (p8 = 1) then
  93.             A := A + 1;
  94.         if (p8 = 0) and (p9 = 1) then
  95.             A := A + 1;
  96.         if (p9 = 0) and (p2 = 1) then
  97.             A := A + 1;
  98.         B := p2 + p3 + p4 + p5 + p6 + p7 + p8 + p9;
  99.         color := 255;
  100.         if A = 1 then
  101.             if (B >= 2) and (B <= 6) then begin
  102.                     if ((p2 * p4 * p6 = 0) and (p4 * p6 * p8 = 0)) and ((p2 * p4 * p8 = 0) and (p2 * p6 * p8 = 0)) then
  103.                         color := 200
  104.                     else if (p2 * p4 * p6 = 0) and (p4 * p6 * p8 = 0) then
  105.                         color := 150
  106.                     else if (p2 * p4 * p8 = 0) and (p2 * p6 * p8 = 0) then
  107.                         color := 100;
  108.                 end;
  109.     end;
  110.  
  111.  
  112.     procedure DoUserCommand1;
  113. {Generates a table showing all possible 3x3 neighborhoods. This table is used}
  114. { for making up the "fate table" used by the Skeletonize command and the Wand tool.}
  115.         var
  116.             row, column, index: integer;
  117.     begin
  118.         row := 0;
  119.         column := 0;
  120.         if NewPicWindow('Fate Table', 600, 200) then
  121.             for index := 0 to 255 do begin
  122.                     SetColor(index);
  123.                     DrawNeighborhood(index, row, column);
  124.                     column := column + 1;
  125.                     if column = 32 then begin
  126.                             row := row + 1;
  127.                             column := 0;
  128.                         end;
  129.                 end;
  130.     end;
  131.  
  132.  
  133.     function isPeak (x, y, MinValue: integer): boolean;
  134.         var
  135.             delta, angle, dx, dy: real;
  136.             v, i, v2, maxv2, x2, y2, v2count, nSamples: integer;
  137.             sample: LineType;
  138.             minlower, count, nLower, maxCount: integer;
  139.             PeakFound: boolean;
  140.             mask: rect;
  141.     begin
  142.         isPeak := false;
  143.         v := MyGetPixel(x, y);
  144.         if v < MinValue then
  145.             exit(isPeak);
  146.         if v <= MyGetPixel(x + 1, y) then
  147.             exit(isPeak);
  148.         if v <= MyGetPixel(x + 1, y + 1) then
  149.             exit(isPeak);
  150.         if v <= MyGetPixel(x, y + 1) then
  151.             exit(isPeak);
  152.         if v <= MyGetPixel(x - 1, y + 1) then
  153.             exit(isPeak);
  154.         if v < MyGetPixel(x - 1, y) then
  155.             exit(isPeak);
  156.         if (v < MyGetPixel(x - 1, y - 1)) then
  157.             exit(isPeak);
  158.         if v < MyGetPixel(x, y - 1) then
  159.             exit(isPeak);
  160.         if v < MyGetPixel(x + 1, y - 1) then
  161.             exit(isPeak);
  162.         nSamples := round(4 * PeakRadius);
  163.         delta := 2.0 * pi / nsamples;
  164.         angle := 0.0;
  165.         maxv2 := round((1.0 - Peakedness) * v);
  166.         for i := 1 to nSamples do begin
  167.                 dx := PeakRadius * cos(angle);
  168.                 dy := PeakRadius * sin(angle);
  169.                 sample[i] := round(GetInterpolatedPixel(x + dx, y + dy));
  170.                 angle := angle + delta;
  171.             end;
  172.         minLower := round(0.677 * nsamples);
  173.         PeakFound := false;
  174.         count := 0;
  175.         i := 1;
  176.         nLower := 0;
  177.         maxCount := nSamples + minLower;
  178.         repeat
  179.             if sample[i] <= maxv2 then
  180.                 nLower := nLower + 1
  181.             else
  182.                 nLower := 0;
  183.             PeakFound := nLower >= minLower;
  184.             i := i + 1;
  185.             if i > nSamples then
  186.                 i := 1;
  187.             count := count + 1;
  188.         until PeakFound or (count = maxCount);
  189.         if PeakFound then begin
  190.                 info := SaveInfo;
  191.                 with info^ do begin
  192.                         SetRect(RoiRect, x - MinSpacing + 1, y - MinSpacing + 1, x + MinSpacing, y + MinSpacing);
  193.                         with RoiRect do begin
  194.                                 if left < 0 then
  195.                                     left := 0;
  196.                                 if top < 0 then
  197.                                     top := 0;
  198.                                 if right > PicRect.right then
  199.                                     right := PicRect.right;
  200.                                 if bottom > PicRect.bottom then
  201.                                     bottom := PicRect.bottom;
  202.                             end;
  203.                         GetRectHistogram;
  204.                         PeakFound := histogram[0] = 0;
  205.                     end; {with}
  206.                 Info := UndoInfo;
  207.             end;
  208.         isPeak := PeakFound;
  209.     end;
  210.  
  211.  
  212.     procedure FindPeaks (MinValue, PeakRadiusP, PeakednessP: extended);
  213.         var
  214.             x, y, i, iMinValue: integer;
  215.             AutoSelectAll: boolean;
  216.             srect, mask: rect;
  217.             count: LongInt;
  218.             t: FateTable;
  219.     begin
  220.         if NotRectangular or NotInBounds or NoUndo then
  221.             exit(FindPeaks);
  222.         iMinValue := round(MinValue);
  223.         if iMinValue < 10 then
  224.             iMinValue := 10;
  225.         if iMinValue > 150 then
  226.             iMinValue := 150;
  227.         PeakRadius := PeakRadiusP;
  228.         if PeakRadius = 0.0 then
  229.             PeakRadius := 6.0;
  230.         if PeakRadius < 1.0 then
  231.             PeakRadius := 1.0;
  232.         if PeakRadius > 50.0 then
  233.             PeakRadius := 50.0;
  234.         MinSpacing := round(PeakRadius) - 1;
  235.         if MinSpacing < 1 then
  236.             MinSpacing := 1;
  237.         if MinSpacing > 4 then
  238.             MinSpacing := 4;
  239.         Peakedness := PeakednessP;
  240.         if Peakedness = 0.0 then
  241.             Peakedness := 0.2;
  242.         if Peakedness < 0.05 then
  243.             Peakedness := 0.05;
  244.         if Peakedness > 0.95 then
  245.             Peakedness := 0.95;
  246.         AutoSelectAll := not Info^.RoiShowing;
  247.         if AutoSelectAll then
  248.             SelectAll(true);
  249.         ShowWatch;
  250.         SetupUndo;
  251.         WhatToUndo := UndoEdit;
  252.         SetupUndoInfoRec;
  253.         SaveInfo := Info;
  254.         srect := info^.roiRect;
  255.         KillRoi;
  256.         ChangeValues(0, 0, 1);
  257.         info := UndoInfo;
  258.         count := 0;
  259.         with srect do
  260.             for y := top to bottom - 1 do begin
  261.                     if CommandPeriod then begin
  262.                             beep;
  263.                             Info := SaveInfo;
  264.                             leave;
  265.                         end;
  266.                     for x := left to right - 1 do
  267.                         if isPeak(x, y, iMinValue) then begin
  268.                                 count := count + 1;
  269.                                 Info := SaveInfo;
  270.                                 PutPixel(x, y, 0);
  271. {PutPixel(x - 1, y, 0);}
  272. {PutPixel(x - 1, y - 1, 0);}
  273. {PutPixel(x, y - 1, 0);}
  274.                                 SetRect(mask, x - 1, y - 1, x + 1, y + 1);
  275.                                 UpdateScreen(mask);
  276.                                 Info := UndoInfo;
  277.                                 if count < MaxMeasurements then begin
  278.                                         User1^[count] := x;
  279.                                         User2^[count] := y;
  280.                                     end;
  281.                                 ShowMessage(concat(long2str(y), '  ', long2str(count)));
  282.                             end;
  283.                 end;
  284.         Info := SaveInfo;
  285.         if count < MaxMeasurements then begin
  286.                 UnsavedResults := false;
  287.                 ResetCounter;
  288.                 for i := 1 to count do begin
  289.                         ClearResults(i);
  290.                         xcenter^[i] := User1^[i];
  291.                         ycenter^[i] := User2^[i];
  292.                     end;
  293.                 mCount := count;
  294.                 UpdateList;
  295.                 ShowValues;
  296.             end
  297.         else
  298.             PutMessage('"Max Measurements" is too small.');
  299.         ShowMessage(concat('Count=', long2str(count), cr, 'Threshold=', long2str(iMinValue)));
  300.     end;
  301.  
  302.  
  303.  
  304.     procedure ComputeBirefringence (scale, offset: real);
  305. {This an example of how to do image math using a UserCode macro routine.}
  306. {It executes the following formula}
  307.  
  308.       {SQRT ( ( I1 - I2 ) ^ 2 + ( I3 - I4 ) ^ 2 ) / ( I1 + I2 - I3 + I4 ) ,}
  309.  
  310. {where I1 , I2 , I3 , I4  are the first four slices of the current stack.}
  311. {The result in the fifth slice of the stack.}
  312.  
  313.         var
  314.             i1, i2, i3, i4, i5: LineType;
  315.             i, slice, row: integer;
  316.             mask: rect;
  317.             v, min, max: real;
  318.             minstr, maxstr: str255;
  319.     begin
  320.         with info^ do begin
  321.                 if StackInfo = nil then
  322.                     exit(ComputeBirefringence);
  323.                 if StackInfo^.nSlices <> 5 then
  324.                     exit(ComputeBirefringence);
  325.                 min := 1.0e12;
  326.                 max := 1.0e-12;
  327.                 for row := 0 to nLines - 1 do begin
  328.                         SelectSlice(1);
  329.                         GetLine(0, row, PixelsPerLine, i1);
  330.                         SelectSlice(2);
  331.                         GetLine(0, row, PixelsPerLine, i2);
  332.                         SelectSlice(3);
  333.                         GetLine(0, row, PixelsPerLine, i3);
  334.                         SelectSlice(4);
  335.                         GetLine(0, row, PixelsPerLine, i4);
  336.                         for i := 0 to PixelsPerLine - 1 do begin
  337.                                 v := sqrt(sqr(I1[i] - I2[i]) + sqr(I3[i] - I4[i])) / (I1[i] + I2[i] - I3[i] + I4[i]);
  338.                                 if v < min then
  339.                                     min := v;
  340.                                 if v > max then
  341.                                     max := v;
  342.                                 if v > 255 then
  343.                                     v := 255;
  344.                                 if v < 0 then
  345.                                     v := 0;
  346.                                 v := v * scale + offset;
  347.                                 i5[i] := round(v);
  348.                             end;
  349.                         SelectSlice(5);
  350.                         PutLine(0, row, PixelsPerLine, i5);
  351.                         SetRect(mask, 0, row, PixelsPerLine, row + 1);
  352.                         UpdateScreen(mask);
  353.                         if CommandPeriod then
  354.                             leave;
  355.                     end;
  356.             end;
  357.         RealToString(min, 1, 4, minstr);
  358.         RealToString(max, 1, 4, maxstr);
  359.         ShowMessage(concat('min=', minstr, cr, 'max=', maxstr));
  360.     end;
  361.  
  362.  
  363.     procedure ShowNoCodeMessage;
  364.     begin
  365.         PutMessage('Requires user written Think Pascal routine. ');
  366.     end;
  367.  
  368.  
  369.     procedure DoUserCommand2;
  370.     begin
  371.         ShowNoCodeMessage
  372.     end;
  373.  
  374.  
  375.     procedure DoUserMenuEvent (MenuItem: integer);
  376.     begin
  377.         case MenuItem of
  378.             1: 
  379.                 DoUserCommand1;
  380.             2: 
  381.                 DoUserCommand2;
  382.         end;
  383.     end;
  384.  
  385.  
  386.     procedure OldUserMacroCode (CodeNumber: integer; Param1, Param2, Param3: extended);
  387.   {Obsolete version kept for backward compatibilty.}
  388.     begin
  389.         case CodeNumber of
  390.             1: 
  391.                 ShowNoCodeMessage;
  392.             2: 
  393.                 ShowNoCodeMessage;
  394.             3: 
  395.                 ShowNoCodeMessage;
  396.             4: 
  397.                 ShowNoCodeMessage;
  398.             5: 
  399.                 FindPeaks(param1, param2, param3);
  400.             otherwise
  401.                 ShowNoCodeMessage;
  402.         end;
  403.     end;
  404.  
  405.  
  406.     procedure UserMacroCode (str: str255; Param1, Param2, Param3: extended);
  407.     begin
  408.         MakeLowerCase(str);
  409.         if pos('peaks', str) <> 0 then begin
  410.                 FindPeaks(param1, param2, param3);
  411.                 exit(UserMacroCode);
  412.             end;
  413.         if pos('birefringence', str) <> 0 then begin
  414.                 ComputeBirefringence(param1, param2);
  415.                 exit(UserMacroCode);
  416.             end;
  417.         ShowNoCodeMessage;
  418.     end;
  419.  
  420.  
  421. end.